home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / cps / genabs.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  13.4 KB  |  383 lines
  1. (* genabs.sml
  2.  *
  3.  * COPYRIGHT (c) 1991 by AT&T Bell Laboratories
  4.  *)
  5.  
  6. (* Note to browsers: You probably don't want to read this,  it's not
  7.  part of the normal Standard ML of New Jersey implementation;
  8.   read generic.sml instead. *)
  9.  
  10. structure GenAbs = 
  11. struct
  12.  
  13. open AbsMach
  14.  
  15. fun realc s =
  16.   let val (sign,s) = case explode s of "~"::rest => (~1.0,rest) | s => (1.0,s)
  17.       fun j(exp,d::dl,mant) = j(exp,dl,mant * 0.1 + real(d))
  18.         | j(0,nil,mant) = mant*sign
  19.         | j(exp,nil,mant) = if exp>0 then j(exp-1,nil,mant*10.0)
  20.                      else j(exp+1,nil,mant*0.1)
  21.       fun h(esign,wholedigits,diglist,exp,nil) = 
  22.             j(esign*exp+wholedigits-1,diglist,0.0)
  23.         | h(es,fd,dl,exp,d::s) = h(es,fd,dl,exp*10+(ord d - ord "0"),s)
  24.       fun g(i,r,"E"::"~"::s)=h(~1,i,r,0,s)
  25.     | g(i,r,"E"::s)=h(1,i,r,0,s)
  26.     | g(i,r,d::s) = g(i, (ord d - ord "0")::r, s)
  27.     | g(i,r,nil) = h(1,i,r,0,nil)
  28.       fun f(i,r,"."::s)=g(i,r,s)
  29.         | f(i,r,s as "E"::_)=g(i,r,s)
  30.         | f(i,r,d::s) = f(i+1,(ord(d)-ord("0"))::r,s)
  31.    in f(0,nil,s)
  32.   end
  33.  
  34. val zeroreg = 0
  35. val allocptr = 1
  36. val exnhandler = 2
  37. val standardclosure = 3
  38. val standardarg = 4
  39. val standardcont = 5
  40. val firstnonstandard = 6
  41.  
  42. open System.Tags Access
  43.  
  44. datatype frag
  45.   = FUNC of reg list * cexp option ref
  46.   | STRINGfrag of string
  47.  
  48. fun standardformals [_,_]   = [standardcont,standardarg]
  49.   | standardformals [_,_,_] = [standardclosure,standardarg,standardcont]
  50.   | standardformals _ = ErrorMsg.impossible "110 in CPSgen"
  51.  
  52. fun codegen(funs : ((lvar * lvar list * cexp) * bool) list, err) =
  53. let 
  54.     exception Regbind and Labbind
  55.     val labtable : label Intmap.intmap = Intmap.new(32, Labbind)
  56.     val addlabbinding = Intmap.add labtable
  57.     val labmap = Intmap.map labtable
  58.  
  59.     val nextlabel = ref 0
  60.     fun newlabel() = !nextlabel before inc nextlabel
  61.  
  62.     val regbindtable : reg Intmap.intmap = Intmap.new(32, Regbind)
  63.     val addbinding = Intmap.add regbindtable
  64.     val regmap = Intmap.map regbindtable
  65.  
  66.     val nextreg = ref firstnonstandard
  67.     fun newreg _ = !nextreg before inc nextreg
  68.  
  69.     exception Know
  70.     val knowtable : frag Intmap.intmap = Intmap.new(32, Know)
  71.     val addknow = Intmap.add knowtable
  72.     val know = Intmap.map knowtable
  73.  
  74.     exception Freemap
  75.     val freemaptable : lvar list Intmap.intmap = Intmap.new(32, Freemap)
  76.     val freemap = Intmap.map freemaptable
  77.  
  78.     fun makefrag ((f,vl,e),known) = 
  79.     let val lab = newlabel()
  80.         val fmls = if known then map newreg vl else standardformals vl
  81.         val knowledge = FUNC(fmls, ref(SOME e))
  82.      in app2 addbinding (vl,fmls);
  83.             addknow(f, knowledge); addlabbinding(f,lab);
  84.         FreeMap.freemap (Intmap.add freemaptable) e;
  85.         (lab,knowledge)
  86.     end
  87.  
  88.     val frags = ref(map makefrag funs)
  89.     fun addfrag f = frags := f :: !frags
  90.  
  91.     fun regbind(VAR v) = regmap v
  92.       | regbind(LABEL v) = let val r = newreg()
  93.                in emit(A.GETLAB{lab=v,dst=r});
  94.                   r
  95.                end
  96.       | regbind(INT i) = let val r = newreg()
  97.              in emit(A.ARITHI{oper=iadd,src1=0,src2=i,dst=r});
  98.                  r
  99.                  end
  100.                   ErrorMsg.impossible "Overflow in cps/generic.sml")
  101.       | regbind(STRING s) = let val r = newreg()
  102.                 val lab = newlabel()
  103.                  in emit(A.GETLAB{lab=lab,dst=r});
  104.                     addfrag(lab, STRINGfrag s);
  105.                 r
  106.                 end
  107.       | regbind(REAL s) = let val r = newreg()
  108.                in emit(A.GETREAL{value=realc s,dst=r});
  109.                   r
  110.               end
  111.  
  112.     fun regbind(VAR v) = regmap v
  113.       | regbind(LABEL v) = let val r = newreg()
  114.                in emit(A.GETLAB{lab=v,dst=r});
  115.                   r
  116.                end
  117.       | regbind(INT i) = let val r = newreg()
  118.              in emit(A.ARITHI{oper=iadd,src1=0,src2=i,dst=r});
  119.                  r
  120.                  end
  121.                   ErrorMsg.impossible "Overflow in cps/generic.sml")
  122.       | regbind(STRING s) = let val r = newreg()
  123.                 val lab = newlabel()
  124.                  in emit(A.GETLAB{lab=lab,dst=r});
  125.                     addfrag(lab, STRINGfrag s);
  126.                 r
  127.                 end
  128.       | regbind(REAL s) = let val r = newreg()
  129.                in emit(A.GETREAL{value=realc s,dst=r});
  130.                   r
  131.               end
  132.  
  133.     fun regbind(VAR v, f) = f(regmap v)
  134.       | regbind(LABEL v, f) = let val r = newreg()
  135.                    in A.GETLAB{lab=v,dst=r} :: f r
  136.                   end
  137.       | regbind(INT 0, r) = f(zeroreg)
  138.       | regbind(INT i, r) = let val r = newreg()
  139.                  in A.ARITHI{oper=iadd,src1=0,src2=i,dst=r} :: f r
  140.                     end
  141.       | regbind(STRING s, r) = let val r = newreg()
  142.                    val lab = newlabel()
  143.                     in addfrag(lab, STRINGfrag s);
  144.                        A.GETLAB{lab=lab,dst=r} :: f r
  145.                    end
  146.       | regbind(REAL s, r) = let val r = newreg()
  147.                   in A.GETREAL{value=realc s,dst=r} :: f r
  148.                  end
  149.  
  150.     fun genfrag (lab, FUNC(fmls, ref NONE)) = ()
  151.       | genfrag (lab, FUNC(fmls, ref e)) =
  152.          (emit(A.LABEL{lab=lab, live=reserved@fmls});
  153.           gen(e,0))
  154.       | genfrag (lab, STRINGfrag s) =
  155.     (emit(A.WORD{value= size s * power_tags + tag_embedded});
  156.          emit(A.LABEL{lab=lab, live=nil});
  157.      emit(A.STRING{value= substring(s^"\000\000\000",0,4*((length s+3)div 4))}))
  158.  
  159.   (* generate a new code label *)
  160.     and genlab(lab, cexp, alloc) = 
  161.     (emit(A.LABEL{lab=lab, live= regmap freevars cexp});
  162.      gen(cexp,alloc))
  163.  
  164.     and call(args,fmls,alloc,jmp) =
  165.     let val r = newreg()
  166.         fun f a = if member a fmls 
  167.               then let val z=newreg()
  168.                    in emit(A.ARITHI{iadd,src1=0,src2=a,dst=z});
  169.                   z
  170.                    end
  171.               else a
  172.      in if alloc<>0 then (emit(A.ARITHI{iadd,src1=allocptr,src2=alloc*4,
  173.                         dst=r});
  174.                   emit(A.MOVE{src=r,dst=allocptr}))
  175.                     else ();
  176.         app2 (fn(a,b)=>emit(A.MOVE{src=a,dst=b})) 
  177.              (map (f o regbind) args, fmls);
  178.         emit jmp
  179.         end
  180.  
  181.      and binop(oper, (_, [INT k, w],[x],[e]), alloc) =
  182.           getreg(x, fn x' =>
  183.              (emit(ARITHI{oper=oper,src1=regbind w,src2=k,dst=x'});
  184.               gen(e,alloc)))
  185.        | binop(oper, (p, [w, v as INT _],x,e), alloc) =
  186.           binop(oper, (p, [v,w],x,e), alloc)
  187.        | binop(oper, (_, [v,w],[x],[e]) =>
  188.           getreg(x, fn x' =>
  189.           (emit(ARITH{oper=oper,src1=regbind v,src2=regbind w,dst=x'});
  190.            gen(e,alloc)))
  191.  
  192.     and gen(cexp,alloc) =
  193.     case cexp
  194.      of RECORD(_, vl,w,e) =>
  195.          let fun f(i,r,OFFp 0) = 
  196.                emit(A.STORE{offset=i*4, src=r, ptr=allocptr})
  197.                | f(i,r,OFFp k) = 
  198.                let val r' = newreg()
  199.                in emit(A.ARITHI{oper=iadd,src1=r,src2=4*k,dst=r'});
  200.               f(i,r',OFFp 0)
  201.                end
  202.                    | f(i,r,SELp(k,p)) =
  203.                let val r' = newreg()
  204.                in emit(A.FETCH{immutable=true,offset=4*k,
  205.                        ptr=r,dst=r'});
  206.               f(i,r',p)
  207.                end
  208.                  fun g(i,nil) = ()
  209.                | g(i,(z,p)::rest) = (f(i,regbind z,p);
  210.                     g(i+1,rest))
  211.  
  212.              in g(vl);
  213.         getreg(w, fn w' => 
  214.             emit(A.ARITHI{oper=iadd,src1=allocptr,src2=4*alloc,dst=w}))
  215.         gen(e,alloc+length vl)
  216.         end
  217.       | SELECT(i,v,w,e) =>
  218.         getreg(w, fn w' => (emit(A.FETCH{immutable=true,offset=4*i,
  219.                          ptr=regbind v,dst=w'});
  220.                 gen(e,alloc)))
  221.       | OFFSET(i,v,w,e) =>
  222.           getreg(w, fn w' => (emit(A.ARITHI{oper=iadd,src1=regbind v,
  223.                         src2=4*i,dst=w'});
  224.                   gen(e,alloc)))
  225.       | APP(func as VAR f, args) => 
  226.           call(args,standardformals args, alloc,A.JUMP{dst=regbind f})
  227.       | APP(func as LABEL f, args) =>
  228.         (case know f
  229.           of FUNC(fmls,_) => 
  230.           call(args,fmls,alloc,A.BRANCH{ieq,src1=0,src2=0,
  231.                         dst=labmap f}))
  232.       | APP _ => ErrorMsg.impossible "constant func in CPSgen"
  233.       | SWITCH(v,l) => 
  234.         let val lab = newlabel()
  235.             val labs = map (fn _ => newlabel()) l;
  236.             fun f s = emit(A.LABWORD{lab=s})
  237.             fun h(lab, e) = genlab(lab, e, alloc)
  238.             val r = newreg() and r' = newreg() 
  239.             and r'' = newreg() and r''' = newreg()
  240.         in emit(A.ARITHI{oper=lshift,src1=regbind v,src2=2,dst=r});
  241.            emit(A.GETLAB{lab=lab,dst=r'});
  242.            emit(A.ARITH{oper=iadd, src1=r,src2=r',dst=r''});
  243.            emit(A.FETCH{immutable=true, offset=0, ptr=r'',dst=r'''});
  244.            emit(A.JUMP{dst=r'''})
  245.            emit(A.LABEL{lab,live=nil})
  246.            app f labs;
  247.            app2 h (labs,l)
  248.         end
  249.         | PRIMOP(P.notb, [v],[x],[e]) =>
  250.           getreg(x, fn x' =>
  251.              (emit(ARITHI{oper=xor,src1=regbind v,src2= ~1,dst=x'});
  252.               gen(e,alloc)))
  253.         | PRIMOP(args as (P.+, _, _, _)) => binop(A.iadd, args, alloc)
  254.         | PRIMOP(args as (P.-, _, _, _)) => binop(A.isub, args, alloc)
  255.         | PRIMOP(args as (P.*, _, _, _)) => binop(A.imul, args, alloc)
  256.         | PRIMOP(args as (P.div, _, _, _)) => binop(A.idiv, args, alloc)
  257.         | PRIMOP(args as (P.fadd, _, _, _)) => binop(A.fadd, args, alloc)
  258.         | PRIMOP(args as (P.fsub, _, _, _)) => binop(A.fsub, args, alloc)
  259.         | PRIMOP(args as (P.fmul, _, _, _)) => binop(A.fmul, args, alloc)
  260.         | PRIMOP(args as (P.fdiv, _, _, _)) => binop(A.fdiv, args, alloc)
  261.         | PRIMOP(args as (P.orb, _, _, _)) => binop(A.orb, args, alloc)
  262.         | PRIMOP(args as (P.andb, _, _, _)) => binop(A.andb, args, alloc)
  263.         | PRIMOP(args as (P.xorb, _, _, _)) => binop(A.xorb, args, alloc)
  264.         | PRIMOP(args as (P.lshift, _, _, _)) => binop(A.rshift, args, alloc)
  265.         | PRIMOP(args as (P.rshift, _, _, _)) => binop(A.rshift, args, alloc)
  266.         | PRIMOP(P.!, [v],[w],[e]) => 
  267.                   gen(PRIMOP(P.subscript,[v, INT 0], [w], [e]))
  268.         | PRIMOP(P.:=, [v,w],[],[e]) => 
  269.                  gen(PRIMOP(P.update, [v,INT 0,w],[],[e]))
  270.         | PRIMOP(P.unboxedassign, [v,w],[],[e]) =>
  271.           gen(PRIMOP(P.:=, [v,w],[],[e]))
  272.        | PRIMOP(P.~, [v],[w],[e]) =>
  273.          gen(PRIMOP(P.-,[INT 0,v],[w],[e]))
  274.        | PRIMOP(P.makeref, [v],[w],[e]) =>
  275.          gen(RECORD(RK_RECORD, [(v,OFFp 0)],[w],[e]))
  276.        | PRIMOP(P.subscript, [v,INT k],[x],[e]) =>
  277.         getreg(x,any, fn x' =>
  278.            (emit(A.FETCH{immutable=false, offset=4*k,
  279.                  ptr=regbind v,dst=x'});
  280.             gen(e,alloc)))
  281.        | PRIMOP(P.subscript, [v,w],[x],[e]) =>
  282.         getreg(x,any, fn x' =>
  283.            let val r = newreg() and r' = newreg()
  284.            in emit(A.ARITHI{oper=lshift,src1=regbind w,src2=2,dst=r'});
  285.               emit(A.ARITH{oper=iadd,src1=regbind v, src2=r',dst=r''});
  286.               emit(A.FETCH{immutable=false, offset=0,ptr=r'',dst=x'});
  287.               gen(e,alloc)
  288.            end)
  289.        | PRIMOP(P.update, [a, INT k, v], [], [e]) =>
  290.            (emit(A.STORE{offset=4*k,ptr=regbind a,src=regbind v});
  291.             gen(e,alloc))
  292.        | PRIMOP(P.update, [a, i, v], [], [e]) =>
  293.            let val r = newreg() and r' = newreg()
  294.            in emit(A.ARITHI{oper=lshift,src1=regbind i,src2=2,dst=r'});
  295.               emit(A.ARITH{oper=iadd,src1=regbind a, src2=r',dst=r''});
  296.               emit(A.STORE{offset=0,ptr=r'',src=regbind v});
  297.               gen(e,alloc)
  298.            end
  299.        | PRIMOP(P.unboxedupdate, [a, i, v], [], [e]) =>
  300.          gen(PRIMOP(P.update,[a, i, v], [], [e]))
  301.        | PRIMOP(P.alength, [a], [x], [e]) =>
  302.          gen(SELECT(~1,a,x,e))
  303.        | PRIMOP(P.slength, [a], [x], [e]) =>
  304.          gen(SELECT(~1,a,x,e))
  305.        | PRIMOP(P.store, [s,INT k,v], [], [e]) =>
  306.          (emit(A.STOREB{offset=k,ptr=regbind s, src=regbind v});
  307.           gen e)
  308.        | PRIMOP(P.store, [s,i,v], [], [e]) =>
  309.          let val r = newreg()
  310.          in emit(A.ARITH{oper=iadd,src1=regbind s,src2=regbind i,dst=r});
  311.         emit(A.STOREB{offset=0,ptr=r,src=regbind v});
  312.         gen e
  313.          end
  314.        | PRIMOP(P.ordof, [s as VAR _, INT k], [v], [e]) =>
  315.          getreg(v,any, fn v' =>
  316.            (fetchindexb(regbind s, v', immed k);
  317.             addl3(v',v',v');
  318.             addl3(immed 1, v',v');
  319.             gen e))
  320.        | PRIMOP(P.ordof, [s, INT k], [v], [e]) =>
  321.         getreg(x,any, fn x' =>
  322.               (emit(A.FETCHB{offset=k,ptr=regbind s,dst=x'});
  323.                gen(e,alloc)))
  324.        | PRIMOP(P.ordof, [s, i], [x], [e]) =>
  325.         getreg(x,any, fn x' =>
  326.            let val r = newreg()
  327.            in emit(A.ARITH{oper=iadd,src1=regbind s,
  328.                    src2=regbind i,dst=r});
  329.               emit(A.FETCHB{offset=0,ptr=r,dst=x'});
  330.               gen(e,alloc)
  331.            end)
  332.        | PRIMOP(P.boxed, [x],[],[a,b]) =>
  333.             let val lab = newlabel()
  334.              in emit(A.BRANCH{test=inrange,src1=x,
  335.                       src2=regbind(INT 256),dst=lab});
  336.             gen(a,alloc);
  337.             genlab(lab,b,alloc)
  338.             end
  339.        | PRIMOP(P.gethdlr, [],[x],[e]) =>
  340.          getreg(x, fn x' => 
  341.             (emit(A.ARITHI{oper=iadd,src1=exnhandler,src2=0,dst=x'});
  342.              gen(e,alloc)))
  343.        | PRIMOP(P.sethdlr, [x],[],[e]) => (move(regbind x, exnptr); gen e)
  344.          (emit(A.MOVE{src=regbind x, dst=exnhandler});
  345.           gen e)
  346.        | PRIMOP(P.lessu, [v,w],[],[d,e]) =>
  347.        let val false_lab = newlabel()
  348.         in rangeChk(regbind v, regbind w, false_lab); 
  349.            gen d;
  350.            genlab(false_lab, e)
  351.        end
  352.        | PRIMOP(P.gequ, [v,w],[],[d,e]) => (* fill this in sometime *)
  353.        | PRIMOP(args as (P.rangechk,_,_,_)) => compare(A.outofrange,args)
  354.        | PRIMOP(args as (P.ieql,_,_,_)) => compare(A.ine,args)
  355.        | PRIMOP(args as (P.ineq,_,_,_)) => compare(A.ieq,args)
  356.        | PRIMOP(args as (P.>   ,_,_,_)) => compare(A.ile,args)
  357.        | PRIMOP(args as (P.>=  ,_,_,_)) => compare(A.ilt,args)
  358.        | PRIMOP(args as (P.<   ,_,_,_)) => compare(A.ige,args)
  359.        | PRIMOP(args as (P.<=  ,_,_,_)) => compare(A.igt,args)
  360.        | PRIMOP(args as (P.feql,_,_,_)) => compare(A.fne,args)
  361.        | PRIMOP(args as (P.fneq,_,_,_)) => compare(A.feq,args)
  362.        | PRIMOP(args as (P.fgt ,_,_,_)) => compare(A.fle,args)
  363.        | PRIMOP(args as (P.flt ,_,_,_)) => compare(A.fge,args)
  364.        | PRIMOP(args as (P.fge ,_,_,_)) => compare(A.flt,args)
  365.        | PRIMOP(args as (P.fle ,_,_,_)) => compare(A.fgt,args)
  366.        | _ => ErrorMsg.impossible "3312 in CPSgen"
  367.  
  368.     and compare(test, (_,[v,w],[],[d,e])) =
  369.         let val lab = newlabel()
  370.          in emit(A.BRANCH{test=test,src1=regbind v, 
  371.                   src2=regbind w, dst=lab}); 
  372.             gen d; genlab(lab, e, alloc)
  373.         end
  374.        
  375. in  (* not necessary with regmasks: emitlong 1; Bogus tag for spacing, boot_v. *)
  376.     let fun loop nil = ()
  377.           | loop (frag::r) = (frags := r; genfrag frag; loop(!frags))
  378.     in loop(!frags)
  379.     end
  380. end
  381.  
  382. end
  383.